home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tclX-6.4 / buildhelp.tcl < prev    next >
Encoding:
Text File  |  1992-12-17  |  14.4 KB  |  440 lines
  1. #
  2. # buildhelp.tcl --
  3. #
  4. # Program to extract help files from TCL manual pages or TCL script files.
  5. # The help directories are built as a hierarchical tree of subjects and help
  6. # files.  
  7. # 
  8. #------------------------------------------------------------------------------
  9. # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
  10. #
  11. # Permission to use, copy, modify, and distribute this software and its
  12. # documentation for any purpose and without fee is hereby granted, provided
  13. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  14. # Mark Diekhans make no representations about the suitability of this
  15. # software for any purpose.  It is provided "as is" without express or
  16. # implied warranty.
  17. #------------------------------------------------------------------------------
  18. # $Id: buildhelp.tcl,v 2.1 1992/10/25 17:07:40 markd Exp $
  19. #------------------------------------------------------------------------------
  20. #
  21. # For nroff man pages, the areas of text to extract are delimited with:
  22. #
  23. #     '@help: subjectdir/helpfile
  24. #     '@endhelp
  25. #
  26. # start in column one. The text between these markers is extracted and stored
  27. # in help/subjectdir/help.  The file must not exists, this is done to enforced 
  28. # cleaning out the directories before help file generation is started, thus
  29. # removing any stale files.  The extracted text is run through:
  30. #
  31. #     nroff -man|col -xb   {col -b on BSD derived systems}
  32. #
  33. # If there is other text to include in the helpfile, but not in the manual 
  34. # page, the text, along with nroff formatting commands, may be included using:
  35. #
  36. #     '@:Other text to include in the help page.
  37. #
  38. # A entry in the brief file, used by apropos my be included by:
  39. #
  40. #     '@brief: Short, one line description
  41. #
  42. # These brief request must occur with in the bounds of a help section.
  43. #
  44. # If some header text, such as nroff macros, need to be preappended to the
  45. # text streem before it is run through nroff, then that text can be bracketed
  46. # with:
  47. #
  48. #     '@header
  49. #     '@endheader
  50. #
  51. # If multiple header blocks are encountered, they will all be preappended.
  52. #
  53. # For TCL script files, which are indentified because they end in ".tcl",
  54. # the text to be extracted is delimited by:
  55. #
  56. #    #@help: subjectdir/helpfile
  57. #    #@endhelp
  58. #
  59. # And brief lines are in the form:
  60. #
  61. #     #@brief: Short, one line description
  62. #
  63. # The only processing done on text extracted from .tcl files it to replace
  64. # the # in column one with a space.
  65. #
  66. #
  67. #-----------------------------------------------------------------------------
  68. # 
  69. # To run this program:
  70. #
  71. #   tcl buildhelp.tcl [-m mergeTree] -b brief.brf helpDir file-1 file-2 ...
  72. #
  73. # o -m mergeTree is a tree of help code, plus a brief file to merge with the
  74. #   help files that are to be extracted.  This will become part of the new
  75. #   help tree.  Used to merge in the documentation from UCB Tcl.
  76. # o -b specified the name of the brief file to create form the @brief entries.
  77. #   It must have an extension of ".brf".
  78. # o helpDir is the help tree root directory.  helpDir should  exists, but any
  79. #   subdirectories that don't exists will be created.  helpDir should be
  80. #   cleaned up before the start of manual page generation, as this program
  81. #   will not overwrite existing files.
  82. # o file-n are the nroff manual pages (.man) or .tcl or .tlib files to extract
  83. #   the help files from.
  84. #
  85. #-----------------------------------------------------------------------------
  86.  
  87. #-----------------------------------------------------------------------------
  88. # Truncate a file name of a help file if the system does not support long
  89. # file names.  If the name starts with `Tcl_', then this prefix is removed.
  90. # If the name is then over 14 characters, it is truncated to 14 charactes
  91. #  
  92. proc TruncFileName {pathName} {
  93.     global G_truncFileNames
  94.  
  95.     if {!$G_truncFileNames} {
  96.         return $pathName}
  97.     set fileName [file tail $pathName]
  98.     if {"[crange $fileName 0 3]" == "Tcl_"} {
  99.         set fileName [crange $fileName 4 end]}
  100.     set fileName [crange $fileName 0 13]
  101.     return "[file dirname $pathName]/$fileName"
  102. }
  103.  
  104. #-----------------------------------------------------------------------------
  105. # Proc to ensure that all directories for the specified file path exists,
  106. # and if they don't create them.  Don't use -path so we can set the
  107. # permissions.
  108.  
  109. proc EnsureDirs {filePath} {
  110.     set dirPath [file dirname $filePath]
  111.     if [file exists $dirPath] return
  112.     foreach dir [split $dirPath /] {
  113.         lappend dirList $dir
  114.         set partPath [join $dirList /]
  115.         if [file exists $partPath] continue
  116.  
  117.         mkdir $partPath
  118.         chmod u=rwx,go=rx $partPath
  119.     }
  120. }
  121.  
  122.  
  123. #-----------------------------------------------------------------------------
  124. #
  125. # Proc to extract nroff text to use as a header to all pass to nroff when
  126. # processing a help file.
  127. #    manPageFH - The file handle of the manual page.
  128. #
  129.  
  130. proc ExtractNroffHeader {manPageFH} {
  131.     global nroffHeader
  132.     while {[gets $manPageFH manLine] >= 0} {
  133.         if {[string first "'@endheader" $manLine] == 0} {
  134.             break;
  135.             }
  136.         if {[string first "'@:" $manLine] == 0} {
  137.             set manLine [csubstr manLine 3 end]
  138.             }
  139.         append nroffHeader "$manLine\n"
  140.         }
  141. }
  142.  
  143. #-----------------------------------------------------------------------------
  144. #
  145. # Proc to extract a nroff help file when it is located in the text.
  146. #    manPageFH - The file handle of the manual page.
  147. #    manLine - The '@help: line starting the data to extract.
  148. #
  149.  
  150. proc ExtractNroffHelp {manPageFH manLine} {
  151.     global G_helpDir nroffHeader G_briefHelpFH G_colArgs
  152.  
  153.     set helpName [string trim [csubstr $manLine 7 end]]
  154.     set helpFile [TruncFileName "$G_helpDir/$helpName"]
  155.     if {[file exists $helpFile]} {
  156.         error "Help file already exists: $helpFile"}
  157.     EnsureDirs $helpFile
  158.     set helpFH [open "| nroff -man | col $G_colArgs > $helpFile" w]
  159.     echo "    creating help file $helpName"
  160.  
  161.     # Nroff commands from .TH macro to get the formatting right.  The `\n'
  162.     # are newline separators to output, the `\\n' become `\n' in the text.
  163.         
  164.     puts $helpFH ".ad b\n.PD\n.nrIN \\n()Mu\n.nr)R 0\n.nr)I \\n()Mu"
  165.     puts $helpFH ".nr)R 0\n.\}E\n.DT\n.na\n.nh"
  166.     puts $helpFH $nroffHeader
  167.     set foundBrief 0
  168.     while {[gets $manPageFH manLine] >= 0} {
  169.         if {[string first "'@endhelp" $manLine] == 0} {
  170.             break;
  171.         }
  172.         if {[string first "'@brief:" $manLine] == 0} {
  173.             if $foundBrief {
  174.                 error {Duplicate "'@brief" entry"}
  175.             }
  176.             set foundBrief 1
  177.         puts $G_briefHelpFH "$helpName\t[csubstr $manLine 8 end]"
  178.             continue;
  179.         }
  180.         if {[string first "'@:" $manLine] == 0} {
  181.             set manLine [csubstr $manLine 3 end]
  182.         }
  183.         if {[string first "'@help" $manLine] == 0} {
  184.             error {"'@help" found within another help section"}
  185.         }
  186.         puts $helpFH $manLine
  187.         }
  188.     close $helpFH
  189.     chmod a-w,a+r $helpFile
  190. }
  191.  
  192. #-----------------------------------------------------------------------------
  193. #
  194. # Proc to extract a tcl script help file when it is located in the text.
  195. #    ScriptPageFH - The file handle of the .tcl file.
  196. #    ScriptLine - The #@help: line starting the data to extract.
  197. #
  198.  
  199. proc ExtractScriptHelp {ScriptPageFH ScriptLine} {
  200.     global G_helpDir G_briefHelpFH
  201.     set helpName [string trim [csubstr $ScriptLine 7 end]]
  202.     set helpFile "$G_helpDir/$helpName"
  203.     if {[file exists $helpFile]} {
  204.         error "Help file already exists: $helpFile"}
  205.     EnsureDirs $helpFile
  206.     set helpFH [open $helpFile w]
  207.     echo "    creating help file $helpName"
  208.     set foundBrief 0
  209.     while {[gets $ScriptPageFH ScriptLine] >= 0} {
  210.         if {[string first "#@endhelp" $ScriptLine] == 0} {
  211.             break;
  212.         }
  213.         if {[string first "#@brief:" $ScriptLine] == 0} {
  214.             if $foundBrief {
  215.                 error {Duplicate "#@brief" entry"}
  216.             }
  217.             set foundBrief 1
  218.         puts $G_briefHelpFH "$helpName\t[csubstr $ScriptLine 8 end]"
  219.             continue;
  220.         }
  221.         if {[string first "#@help" $ScriptLine] == 0} {
  222.             error {"#@help" found within another help section"}
  223.         }
  224.         if {[clength $ScriptLine] > 1} {
  225.             set ScriptLine " [csubstr $ScriptLine 1 end]"
  226.         } else {
  227.             set ScriptLine ""
  228.         }
  229.         puts $helpFH $ScriptLine
  230.         }
  231.     close $helpFH
  232.     chmod a-w,a+r $helpFile
  233. }
  234.  
  235. #-----------------------------------------------------------------------------
  236. #
  237. # Proc to scan a nroff manual file looking for the start of a help text
  238. # sections and extracting those sections.
  239. #    pathName - Full path name of file to extract documentation from.
  240. #
  241.  
  242. proc ProcessNroffFile {pathName} {
  243.    global G_nroffScanCT G_scriptScanCT nroffHeader
  244.  
  245.    set fileName [file tail $pathName]
  246.  
  247.    set nroffHeader {}
  248.    set manPageFH [open $pathName r]
  249.    echo "    scanning $pathName"
  250.    set matchInfo(fileName) [file tail $pathName]
  251.    scanfile $G_nroffScanCT $manPageFH
  252.    close $manPageFH
  253. }
  254.  
  255. #-----------------------------------------------------------------------------
  256. #
  257. # Proc to scan a Tcl script file looking for the start of a
  258. # help text sections and extracting those sections.
  259. #    pathName - Full path name of file to extract documentation from.
  260. #
  261.  
  262. proc ProcessTclScript {pathName} {
  263.    global G_scriptScanCT nroffHeader
  264.  
  265.    set scriptFH [open "$pathName" r]
  266.  
  267.    echo "    scanning $pathName"
  268.    set matchInfo(fileName) [file tail $pathName]
  269.    scanfile $G_scriptScanCT $scriptFH
  270.    close $scriptFH
  271. }
  272.  
  273. #-----------------------------------------------------------------------------
  274. # Proc to copy the help merge tree, excluding the brief file and RCS files
  275. # 
  276.  
  277. proc CopyMergeTree {helpDirPath mergeTree} {
  278.     if {"[cindex $helpDirPath 0]" != "/"} {
  279.         set helpDirPath "[pwd]/$helpDirPath"
  280.     }
  281.     set oldDir [pwd]
  282.     cd $mergeTree
  283.  
  284.     set curHelpDir "."
  285.  
  286.     for_recursive_glob mergeFile {.} {
  287.         if [string match "*/RCS/*" $mergeFile] continue
  288.  
  289.         set helpFile "$helpDirPath/$mergeFile"
  290.         if [file isdirectory $mergeFile] continue
  291.  
  292.         if {[file exists $helpFile]} {
  293.             error "Help file already exists: $helpFile"}
  294.         EnsureDirs $helpFile
  295.         set inFH [open $mergeFile r]
  296.         set outFH [open $helpFile w]
  297.         copyfile $inFH $outFH
  298.         close $outFH
  299.         close $inFH
  300.         chmod a-w,a+r $helpFile
  301.     }
  302.     cd $oldDir
  303. }
  304.  
  305. #-----------------------------------------------------------------------------
  306. # GenerateHelp: main procedure.  Generates help from specified files.
  307. #    helpDirPath - Directory were the help files go.
  308. #    mergeTree - Help file tree to merge with the extracted help files.
  309. #    briefFile - The name of the brief file to create.
  310. #    sourceFiles - List of files to extract help files from.
  311.  
  312. proc GenerateHelp {helpDirPath briefFile mergeTree sourceFiles} {
  313.     global G_helpDir G_truncFileNames G_nroffScanCT
  314.     global G_scriptScanCT G_briefHelpFH G_colArgs
  315.  
  316.     echo ""
  317.     echo "Begin building help tree"
  318.  
  319.     # Determine version of col command to use (no -x on BSD)
  320.     if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
  321.         set G_colArgs {-b}
  322.     } else {
  323.         set G_colArgs {-bx}
  324.     }
  325.     set G_helpDir [glob $helpDirPath]
  326.  
  327.     if {![file isdirectory $G_helpDir]} {
  328.         error [concat "$G_helpDir is not a directory or does not exist. "  
  329.                       "This should be the help root directory"]
  330.     }
  331.         
  332.     set status [catch {set tmpFH [open $G_helpDir/AVeryVeryBigFileName w]}]
  333.     if {$status != 0} {
  334.         set G_truncFileNames 1
  335.     } else {
  336.         close $tmpFH
  337.         unlink $G_helpDir/AVeryVeryBigFileName
  338.         set G_truncFileNames 0
  339.     }
  340.  
  341.     set G_nroffScanCT [scancontext create]
  342.  
  343.     scanmatch $G_nroffScanCT "^'@help:" {
  344.         ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
  345.         continue
  346.     }
  347.  
  348.     scanmatch $G_nroffScanCT "^'@header" {
  349.         ExtractNroffHeader $matchInfo(handle)
  350.         continue
  351.     }
  352.     scanmatch $G_nroffScanCT "^'@endhelp" {
  353.         error [concat {"'@endhelp" without corresponding "'@help:"} \
  354.                  ", offset = $matchInfo(offset)"]
  355.     }
  356.     scanmatch $G_nroffScanCT "^'@brief" {
  357.         error [concat {"'@brief" without corresponding "'@help:"}
  358.                  ", offset = $matchInfo(offset)"]
  359.     }
  360.  
  361.     set G_scriptScanCT [scancontext create]
  362.     scanmatch $G_scriptScanCT "^#@help:" {
  363.         ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
  364.     }
  365.  
  366.     if ![lempty $mergeTree] {
  367.         echo "    Merging tree: $mergeTree"
  368.         CopyMergeTree $helpDirPath $mergeTree
  369.     }
  370.  
  371.  
  372.     if {[file extension $briefFile] != ".brf"} {
  373.         puts stderr "Brief file \"$briefFile\" must have an extension \".brf\""
  374.         exit 1
  375.     }
  376.     if [file exists $G_helpDir/$briefFile] {
  377.         puts stderr "Brief file \"$G_helpDir/$briefFile\" already exists"
  378.         exit 1
  379.     }
  380.     set G_briefHelpFH [open "|sort > $G_helpDir/$briefFile" w]
  381.  
  382.     foreach manFile $sourceFiles {
  383.         set manFile [glob $manFile]
  384.         set ext [file extension $manFile]
  385.         if {"$ext" == ".man"} {
  386.             set status [catch {ProcessNroffFile $manFile} msg]
  387.         } else {
  388.             set status [catch {ProcessTclScript $manFile} msg]
  389.         }
  390.         if {$status != 0} {
  391.             echo "Error extracting help from: $manFile"
  392.             echo $msg
  393.             global errorInfo interactiveSession
  394.             if {!$interactiveSession} {
  395.                 echo $errorInfo
  396.                 exit 1
  397.             }
  398.         }
  399.     }
  400.  
  401.     close $G_briefHelpFH
  402.     chmod a-w,a+r $G_helpDir/$briefFile
  403.     echo "*** completed extraction of all help files"
  404. }
  405.  
  406. #-----------------------------------------------------------------------------
  407. # Print a usage message and exit the program
  408. proc Usage {} {
  409.     puts stderr {Wrong args: [-m mergetree] -b briefFile helpdir manfile1 [manfile2..]}
  410.     exit 1
  411. }
  412.  
  413. #-----------------------------------------------------------------------------
  414. # Main program body, decides if help is interactive or batch.
  415.  
  416. if {$interactiveSession} {
  417.     echo "To extract help, use the command:"
  418.     echo {GenerateHelp helpdir -m mergetree file-1 file-2 ...}
  419. } else {
  420.     set mergeTree {}
  421.     set briefFile {}
  422.     while {[string match "-*" [lindex $argv 0]]} {
  423.         set flag [lvarpop argv 0]
  424.         case $flag in {
  425.             "-m" {set mergeTree [lvarpop argv]}
  426.             "-b" {set briefFile [lvarpop argv]}
  427.             default Usage
  428.         }
  429.     }
  430.     if {[llength $argv] < 2} {
  431.         Usage
  432.     }
  433.     if [lempty $briefFile] {
  434.        puts stderr {must specify -b argument}
  435.        Usage 
  436.     }
  437.     GenerateHelp [lindex $argv 0] $briefFile $mergeTree [lrange $argv 1 end]
  438.    
  439. }
  440.